home *** CD-ROM | disk | FTP | other *** search
/ Hardcore Visual Basic 5.0 (2nd Edition) / Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso / Code / COLORP~1.CTL < prev    next >
Text File  |  1997-06-14  |  9KB  |  294 lines
  1. VERSION 5.00
  2. Begin VB.UserControl XColorPicker 
  3.    Alignable       =   -1  'True
  4.    BorderStyle     =   1  'Fixed Single
  5.    ClientHeight    =   2880
  6.    ClientLeft      =   0
  7.    ClientTop       =   0
  8.    ClientWidth     =   3840
  9.    ScaleHeight     =   192
  10.    ScaleMode       =   3  'Pixel
  11.    ScaleWidth      =   256
  12.    ToolboxBitmap   =   "ColorPicker.ctx":0000
  13. End
  14. Attribute VB_Name = "XColorPicker"
  15. Attribute VB_GlobalNameSpace = False
  16. Attribute VB_Creatable = True
  17. Attribute VB_PredeclaredId = False
  18. Attribute VB_Exposed = True
  19. Option Explicit
  20.  
  21. Public Enum EErrorColorPicker
  22.     eeBaseColorPicker = 13700   ' XColorPicker
  23. End Enum
  24.  
  25. Private aColor() As OLE_COLOR
  26. Private clrCur As OLE_COLOR
  27. Private ixCur As Long, iyCur As Long, ixMax As Long, iyMax As Long
  28. Private fWide As Boolean, fDragging As Boolean
  29.  
  30. Event Picked(Color As OLE_COLOR)
  31. Event MovedOver(Color As OLE_COLOR)
  32. Event MouseDownOn(Color As OLE_COLOR)
  33.  
  34. ' Initialize Properties for User Control
  35. Private Sub UserControl_InitProperties()
  36.     BugLocalMessage "UserControl_InitProperties"
  37.     Wide = False
  38.     Color = vbWhite
  39.     Extender.Name = UniqueControlName("pick", Extender)
  40.     UserControl_Load
  41. End Sub
  42.  
  43. ' Load property values from storage
  44. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  45.     BugLocalMessage "UserControl_ReadProperties"
  46.     Wide = PropBag.ReadProperty("Wide", False)
  47.     Color = PropBag.ReadProperty("Color", vbWhite)
  48.     UserControl_Load
  49. End Sub
  50.  
  51. ' Write property values to storage
  52. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  53.     BugLocalMessage "UserControl_WriteProperties"
  54.     PropBag.WriteProperty "Wide", Wide, False
  55.     PropBag.WriteProperty "Color", Color, vbWhite
  56. End Sub
  57.  
  58. Sub UserControl_Load()
  59.     BugLocalMessage "UserControl_Load"
  60. End Sub
  61.  
  62. Private Sub UserControl_Show()
  63.     BugLocalMessage "UserControl_Show"
  64. End Sub
  65.  
  66. Private Sub UserControl_Resize()
  67.     BugLocalMessage "UserControl_Resize"
  68.     ' Set the form width and height exactly
  69.     Size ScaleX((ixMax * 17) + 5, vbPixels, vbTwips), _
  70.          ScaleY((iyMax * 17) + 5, vbPixels, vbTwips)
  71.     Refresh
  72. End Sub
  73.  
  74. Private Sub UserControl_Paint()
  75.     BugLocalMessage "UserControl_Paint"
  76.     Dim ix As Long, iy As Long
  77.     ' Draw colors in their boxes
  78.     FillStyle = vbSolid
  79.     For ix = 1 To ixMax
  80.         For iy = 1 To iyMax
  81.             FillColor = aColor(ix, iy)
  82.             Line (((ix - 1) * 17) + 1, _
  83.                   ((iy - 1) * 17) + 1)-Step(15, 15), , B
  84.         Next
  85.     Next
  86.     DrawSelection ixCur, iyCur, True
  87. End Sub
  88.  
  89. Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, _
  90.                                   X As Single, Y As Single)
  91.     DrawSelection ixCur, iyCur, False
  92.     ' Calculate the current position
  93.     ixCur = ((X + 1) \ 17) + 1
  94.     iyCur = ((Y + 1) \ 17) + 1
  95.     If ixCur > ixMax Then ixCur = ixMax
  96.     If iyCur > iyMax Then iyCur = iyMax
  97.     fDragging = True
  98.     DrawSelection ixCur, iyCur, True
  99.     RaiseEvent MouseDownOn(aColor(ixCur, iyCur))
  100. End Sub
  101.  
  102. Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, _
  103.                                   X As Single, Y As Single)
  104.     ' Calculate the current position
  105.     Dim ix As Long, iy As Long
  106.     ix = ((X + 1) \ 17) + 1
  107.     iy = ((Y + 1) \ 17) + 1
  108.     If ix > ixMax Then ix = ixMax
  109.     If iy > iyMax Then iy = iyMax
  110.     If fDragging Then
  111.         DrawSelection ixCur, iyCur, False
  112.         ixCur = ix: iyCur = iy
  113.         DrawSelection ixCur, iyCur, True
  114.     End If
  115.     RaiseEvent MovedOver(aColor(ix, iy))
  116. End Sub
  117.  
  118. Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, _
  119.                                 X As Single, Y As Single)
  120.     clrCur = aColor(ixCur, iyCur)
  121.     FillColor = clrCur
  122.     fDragging = False
  123.     RaiseEvent Picked(clrCur)
  124. End Sub
  125.  
  126. Property Get Color() As OLE_COLOR
  127.     Color = clrCur
  128. End Property
  129.  
  130. Property Let Color(clrCurA As OLE_COLOR)
  131.     Dim ix As Long, iy As Long
  132.     For ix = 1 To ixMax
  133.         For iy = 1 To iyMax
  134.             If aColor(ix, iy) = clrCurA Then
  135.                 ixCur = ix: iyCur = iy
  136.                 clrCur = clrCurA
  137.                 If ixCur Then UserControl_Paint
  138.                 PropertyChanged "Wide"
  139.                 Exit Property
  140.             End If
  141.         Next
  142.     Next
  143. End Property
  144.  
  145. Property Get Wide() As Boolean
  146.     Wide = fWide
  147. End Property
  148.  
  149. Property Let Wide(fWideA As Boolean)
  150.     Dim clr As OLE_COLOR
  151.     fWide = fWideA
  152.     If fWide Then
  153.         ixMax = 16
  154.         iyMax = 3
  155.     Else
  156.         ixMax = 8
  157.         iyMax = 6
  158.     End If
  159.     clr = Color
  160.     InitArray
  161.     Color = clr
  162.     UserControl_Resize
  163.     PropertyChanged "Wide"
  164. End Property
  165.  
  166. Sub DrawSelection(ByVal ix As Long, ByVal iy As Long, fSelect As Boolean)
  167.     ' Box the selection
  168.     If ix = 0 And iy = 0 Then Exit Sub
  169.     Dim ordFillStyle As FillStyleConstants
  170.     ordFillStyle = FillStyle
  171.     FillStyle = vbTransparent
  172.     FillColor = aColor(ix, iy)
  173.     If fSelect Then
  174.         Line (((ix - 1) * 17) + 1, _
  175.               ((iy - 1) * 17) + 1)-Step(15, 15), vbBlack, B
  176.         Line (((ix - 1) * 17), _
  177.               ((iy - 1) * 17))-Step(16, 16), vbWhite, B
  178.         Line (((ix - 1) * 17) + 1, _
  179.               ((iy - 1) * 17) + 1)-Step(14, 14), vbBlack, B
  180.     Else
  181.         Line (((ix - 1) * 17), _
  182.               ((iy - 1) * 17))-Step(16, 16), vbButtonFace, B
  183.         Line (((ix - 1) * 17) + 1, _
  184.               ((iy - 1) * 17) + 1)-Step(15, 15), , B
  185.     End If
  186.     FillStyle = ordFillStyle
  187. End Sub
  188.  
  189. Sub InitArray()
  190.     ReDim aColor(1 To ixMax, 1 To iyMax) As Long
  191.     If fWide Then
  192.         aColor(1, 1) = &HFFFFFF
  193.         aColor(1, 2) = &HC0C0C0
  194.         aColor(1, 3) = &H808080
  195.         aColor(2, 1) = &HE0E0E0
  196.         aColor(2, 2) = &H404040
  197.         aColor(2, 3) = &H0
  198.         aColor(3, 1) = &HC0C0FF
  199.         aColor(3, 2) = &H8080FF
  200.         aColor(3, 3) = &HFF&
  201.         aColor(4, 1) = &HC0E0FF
  202.         aColor(4, 2) = &H80C0FF
  203.         aColor(4, 3) = &H80FF&
  204.         aColor(5, 1) = &HC0FFFF
  205.         aColor(5, 2) = &H80FFFF
  206.         aColor(5, 3) = &HFFFF&
  207.         aColor(6, 1) = &HC0FFC0
  208.         aColor(6, 2) = &H80FF80
  209.         aColor(6, 3) = &HFF00&
  210.         aColor(7, 1) = &HFFFFC0
  211.         aColor(7, 2) = &HFFFF80
  212.         aColor(7, 3) = &HFFFF00
  213.         aColor(8, 1) = &HFFC0C0
  214.         aColor(8, 2) = &HFF8080
  215.         aColor(8, 3) = &HFF0000
  216.         aColor(9, 1) = &HFFC0FF
  217.         aColor(9, 2) = &HFF80FF
  218.         aColor(9, 3) = &HFF00FF
  219.         aColor(10, 1) = &HC0&
  220.         aColor(10, 2) = &H80&
  221.         aColor(10, 3) = &H40&
  222.         aColor(11, 1) = &H40C0&
  223.         aColor(11, 2) = &H4080&
  224.         aColor(11, 3) = &H404080
  225.         aColor(12, 1) = &HC0C0&
  226.         aColor(12, 2) = &H8080&
  227.         aColor(12, 3) = &H4040&
  228.         aColor(13, 1) = &HC000&
  229.         aColor(13, 2) = &H8000&
  230.         aColor(13, 3) = &H4000&
  231.         aColor(14, 1) = &HC0C000
  232.         aColor(14, 2) = &H808000
  233.         aColor(14, 3) = &H404000
  234.         aColor(15, 1) = &HC00000
  235.         aColor(15, 2) = &H800000
  236.         aColor(15, 3) = &H400000
  237.         aColor(16, 1) = &HC000C0
  238.         aColor(16, 2) = &H800080
  239.         aColor(16, 3) = &H400040
  240.     Else
  241.         ' Initialize color array
  242.         aColor(1, 1) = &HFFFFFF
  243.         aColor(1, 2) = &HE0E0E0
  244.         aColor(1, 3) = &HC0C0C0
  245.         aColor(1, 4) = &H808080
  246.         aColor(1, 5) = &H404040
  247.         aColor(1, 6) = &H0&
  248.         aColor(2, 1) = &HC0C0FF
  249.         aColor(2, 2) = &H8080FF
  250.         aColor(2, 3) = &HFF&
  251.         aColor(2, 4) = &HC0&
  252.         aColor(2, 5) = &H80
  253.         aColor(2, 6) = &H40
  254.         aColor(3, 1) = &HC0E0FF
  255.         aColor(3, 2) = &H80C0FF
  256.         aColor(3, 3) = &H80FF&
  257.         aColor(3, 4) = &H40C0&
  258.         aColor(3, 5) = &H4080&
  259.         aColor(3, 6) = &H404080
  260.         aColor(4, 1) = &HC0FFFF
  261.         aColor(4, 2) = &H80FFFF
  262.         aColor(4, 3) = &HFFFF&
  263.         aColor(4, 4) = &HC0C0&
  264.         aColor(4, 5) = &H8080&
  265.         aColor(4, 6) = &H4040&
  266.         aColor(5, 1) = &HC0FFC0
  267.         aColor(5, 2) = &H80FF80
  268.         aColor(5, 3) = &HFF00&
  269.         aColor(5, 4) = &HC000&
  270.         aColor(5, 5) = &H8000&
  271.         aColor(5, 6) = &H4000&
  272.         aColor(6, 1) = &HFFFFC0
  273.         aColor(6, 2) = &HFFFF80
  274.         aColor(6, 3) = &HFFFF00
  275.         aColor(6, 4) = &HC0C000
  276.         aColor(6, 5) = &H808000
  277.         aColor(6, 6) = &H404000
  278.         aColor(7, 1) = &HFFC0C0
  279.         aColor(7, 2) = &HFF8080
  280.         aColor(7, 3) = &HFF0000
  281.         aColor(7, 4) = &HC00000
  282.         aColor(7, 5) = &H800000
  283.         aColor(7, 6) = &H400000
  284.         aColor(8, 1) = &HFFC0FF
  285.         aColor(8, 2) = &HFF80FF
  286.         aColor(8, 3) = &HFF00FF
  287.         aColor(8, 4) = &HC000C0
  288.         aColor(8, 5) = &H800080
  289.         aColor(8, 6) = &H400040
  290.     End If
  291. End Sub
  292.  
  293.  
  294.